home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / mdebug.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  23.3 KB  |  774 lines
  1. (in-package "MAXIMA")
  2.  
  3. (eval-when (compile eval)
  4.   (proclaim '(optimize (safety 2) (space 3))
  5.         )
  6.  
  7. (defmacro f (op &rest args)
  8.     `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )))
  9. (defmacro fb (op &rest args)
  10.     `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))
  11.  
  12. )
  13.  
  14. (defun $bt()
  15.   (sloop for v in baktrcl
  16.      do 
  17.      (and (consp v)
  18.           (consp (cadar v))
  19.           (eq (caadar v) 'src))
  20.      ($print  (format nil "~a:~a:" (nth 1 (cadar v))
  21.               (nth 0 (cadar v)) ) v)))
  22.  
  23. ;;*mlambda-call-stack*
  24. ;;#(NIL ($X) (1) $FF ($BIL $X) ($Y) (36) $JOE ($Y $BIL $X) ($JJX) (36)
  25. ;; to get to current values in ff need to unbind bindlist downto ($BIL $X)
  26. ;; to get to current values in joe need to unbind bindlist downto ($Y $BIL $X)
  27.  
  28. (defvar *current-frame* 0)
  29. (defvar $mdebug_print_length 100 "Length of forms to print out in debugger")
  30. (defmacro bak-top-form (x) x)
  31. (defun frame-info (n)
  32.   (declare (fixnum n))
  33.   (let* ((ar  *mlambda-call-stack*)
  34.      (m (length ar))
  35.      fname vals params backtr lineinfo bdlist
  36.      )
  37.     (declare (type (vector t) ar))
  38.     (declare (fixnum m))
  39.     ;; just in case we do not have an even multiple
  40.     (setq m (f - m (f mod m 5) (* n 5)))
  41.     (if (<= m 0 ) (return-from frame-info nil))
  42.     (setq fname (aref ar (f- m 1)))
  43.     (setq vals (aref ar (f- m 2)))
  44.     (setq params (aref ar (f- m 3)))
  45.     (setq backtr (aref ar (f- m 4)))
  46.     (setq bdlist (if (< m (fill-pointer ar)) (aref ar m) bindlist))
  47.    ; (setq lineinfo (get-lineinfo backtr))
  48.     (setq lineinfo (if ( < m (fill-pointer ar))
  49.           (get-lineinfo (bak-top-form (aref ar (f+ m 1))))
  50.           (get-lineinfo (bak-top-form *last-meval1-form*))))
  51.     #+if-you-use-baktrcl 
  52.       (if ( < m (fill-pointer ar))
  53.           (get-lineinfo (bak-top-form (aref ar (f+ m 1))))
  54.         (or (get-lineinfo (bak-top-form *last-meval1-form*
  55.                         ;baktrcl
  56.                         ))
  57.         ;(get-lineinfo (bak-top-form (cdr baktrcl)))
  58.         ))
  59.     (values fname vals params backtr lineinfo bdlist)
  60.     ))
  61.  
  62. (defun print-one-frame (n print-frame-number &aux val (st *debug-io*))
  63.   (multiple-value-bind
  64.     (fname vals params backtr lineinfo bdlist)
  65.     (frame-info n)
  66.     (cond (fname
  67.        (princ (if print-frame-number
  68.               ($sconcat "#" n ": "  fname "(")
  69.             ($sconcat  fname "("))
  70.               st)
  71.        (sloop  for v on params for w in vals
  72.            do (setq val ($sconcat w))
  73.            (if (> (length val) 100)
  74.                (setq val ($sconcat (subseq val 0 100) "...")))
  75.            (format st "~(~a~)=~a~a" ($sconcat (car v)) val
  76.                (if (cdr v) "," "")))
  77.        (princ ")" st)
  78.        (and lineinfo (format st "(~a line ~a)" (short-name (cadr lineinfo))(car lineinfo)))
  79.        (terpri st)
  80.        (values fname vals params backtr lineinfo bdlist))
  81.       (t nil))))
  82.  
  83.  
  84. ;; these are in the system package in gcl...
  85. #-gcl
  86. (progn 'compile
  87. ;; return path as a string  or nil if none.
  88. (defun stream-name (path)
  89.   (let ((tem (errset (namestring (pathname path)))))
  90.     (car tem)))
  91.  
  92. (defun break-call (key args prop &aux fun )
  93.   (setq fun (complete-prop key 'keyword prop))
  94.   (setq key fun)
  95.   (or fun (return-from break-call nil))
  96.   ; jfa commented out the following line. Did it ever work?
  97.   ;#+clisp (eval '(setq *break-env* (the-environment)))
  98.   (setq fun (get fun prop))
  99.   (unless (symbolp fun)  (let ((gen (gensym)))
  100.      (setf (symbol-function gen) fun) (setf (get key prop) gen)
  101.      (setq fun gen)))
  102.   (cond (fun
  103.      (setq args (cons fun args))
  104.      ; jfa temporary hack
  105.      #+gcl(evalhook args nil nil *break-env*)
  106.      #-gcl(eval args)
  107.      )
  108.     (t (format *debug-io* "~&~S is undefined break command.~%" key)))
  109.  )
  110.  
  111. (defun complete-prop (sym package prop &optional return-list)
  112.   (cond ((and (symbolp sym)(get sym prop)(equal (symbol-package sym)
  113.                          (find-package package)))
  114.      (return-from complete-prop sym)))
  115.   (sloop for v in-package package 
  116.      when (and (get v prop)
  117.            (eql #+gcl (string-match sym v)
  118.                         #-gcl (search (symbol-name sym) (symbol-name v)) 
  119.             0)
  120.             )
  121.      collect v into all
  122.      finally
  123.        
  124.          (cond (return-list (return-from complete-prop all))
  125.                ((> (length all) 1)
  126.                     (format t "~&Not unique with property ~(~a: ~{~s~^, ~}~)."
  127.             prop all))
  128.  
  129.                ((null all)
  130.             (format t "~& ~a is not break command" sym))
  131.                (t (return-from complete-prop
  132.                        (car all))))))
  133.  
  134.  
  135.  
  136. )
  137.  
  138.  
  139. (defun $backtrace (&optional (n 30))
  140.   (let ( $display2d   (st *debug-io* ))
  141.     (sloop for i below n
  142.        for j from *current-frame*
  143.        while (print-one-frame j t))))
  144.  
  145. ;; the following are in the maxima package....
  146. ;; they are DIFFERENT from ones in si package..
  147.  
  148. ;; if this is NIL then nothing more is checked in eval
  149. ;;
  150. (defvar *break-points* nil)
  151. (defvar *break-point-vector* (make-array 10 :fill-pointer 0 :adjustable t))
  152. (defun init-break-points ()
  153.   (setf (fill-pointer *break-point-vector*) 0)
  154.   (setf *break-points* *break-point-vector*))
  155. (defvar *break-step* nil)
  156. (defvar *step-next* nil)
  157. (defun step-into (&optional (n 1))
  158.   ;;FORM is the next form about to be evaluated.
  159.    n
  160.   (or *break-points* (init-break-points))
  161.   (setq *break-step* 'break-step-into)
  162.   :resume)
  163.  
  164. (defun step-next ( &optional (n 1))
  165.   n
  166.   (let ((fun (current-step-fun)))
  167.     (setq *step-next* (cons n fun))
  168.     (or *break-points* (init-break-points))
  169.     (setq *break-step* 'break-step-next)
  170.     :resume))
  171.  
  172.  
  173. (defun maybe-break (form line-info fun env &aux pos)
  174.   env
  175.   (cond ((setq pos (position form line-info))
  176.      (setq *break-step* nil)
  177.      (or (> (length *break-points*) 0)
  178.          (setf *break-points* nil))
  179.      (break-dbm-loop (make-break-point fun line-info pos))
  180.      t)))
  181.  
  182. ;; These following functions, when they are the value of *break-step*
  183. ;; are invoked by an inner hook in eval.   They may choose to stop
  184. ;; things.
  185. (defvar *BREAK-STEP* nil)
  186. (defun break-step-into (form &optional env)
  187.   (let ((fun (current-step-fun)))
  188.     (let ((line-info (set-full-lineinfo fun)))
  189.       (and line-info 
  190.        (maybe-break form line-info fun env)))))
  191.  
  192. (defun break-step-next (form &optional env)
  193.   (let ((fun (current-step-fun)))
  194.       (cond ((eql (cdr *step-next*) fun)
  195.          (let ((line-info (set-full-lineinfo fun )))
  196.            (maybe-break form line-info fun env))))))
  197.  
  198. (defvar *lineinfo-array-internal* nil)
  199. ;; the lineinfo for a function will be a vector of forms
  200. ;; such that each one is the first form on a line.
  201. ;; we will walk thru the tree taking the first occurrence
  202. ;; for each line.
  203. (defun set-full-lineinfo (fname &aux te )
  204.   (let ((body (get fname 'lineinfo)))
  205.     (cond ((atom body) (return-from set-full-lineinfo body))
  206.       (t (cond ((null *lineinfo-array-internal*)
  207.             (setq *lineinfo-array-internal*
  208.               (make-array 20 :fill-pointer 0 :adjustable t)))
  209.            (t (setf (fill-pointer *lineinfo-array-internal*) 0)))
  210.          (cond ((setq te (get-lineinfo body))
  211.             (vector-push (car te) *lineinfo-array-internal*)
  212.             (walk-get-lineinfo body  *lineinfo-array-internal*)))
  213.          (cond ((> (fill-pointer *lineinfo-array-internal*) 0)
  214.                 (setf (get fname 'lineinfo)
  215.                   (copy-seq *lineinfo-array-internal*)))
  216.            (t (setf (get fname 'lineinfo) nil)))))))
  217.  
  218. (defun walk-get-lineinfo (form ar &aux (i 0) tem)
  219.   (declare (type (vector t) ar) (fixnum i))
  220.   (cond ((atom form) nil)
  221.     ((setq tem (get-lineinfo form))
  222.      (setq i (f - (line-info-line tem) (aref ar 0) -1 ))
  223.      (cond ((< i (fill-pointer ar))
  224.         (or (aref ar i)
  225.             (setf (aref ar i) form)))
  226.            (t (or (< i (array-total-size ar))
  227.               (adjust-array ar (+ i 20) :fill-pointer (fill-pointer ar)
  228.                     ))
  229.           
  230.           (sloop for j from (fill-pointer ar) below i
  231.              do (setf (aref ar j) nil))
  232.           (setf (fill-pointer ar) (f + i 1))
  233.           (setf (aref ar i) form)))
  234.      (sloop for v in (cdr form)
  235.         do (or (atom v)
  236.                (walk-get-lineinfo v ar))))))
  237.  
  238. (defun first-form-line (form line &aux tem)
  239.   (cond ((atom form) nil)
  240.     ((and (setq tem (get-lineinfo form)) (eql (car tem) line))
  241.      form)
  242.     (t (sloop for v in (cdr form)
  243.           when (setq tem (first-form-line v line))
  244.           do (return-from first-form-line tem)))))
  245.  
  246. (defvar *last-dbm-command* nil)
  247.  
  248. ;; split string into a list of strings, split by any of a list of characters
  249. ;; in bag.  Returns a list.  They will have fill pointers..
  250. (defun split-string (string  bag &optional (start 0) &aux all pos v l)
  251.   (declare (fixnum start ) (type string string) )
  252.   (sloop for i from start below (length string)
  253.      do  (setq pos (position (setq v (aref string i)) bag))
  254.      (setq start (+ start 1))
  255.      (cond ((null pos) (push v all))
  256.            (t (if all (loop-finish))))
  257.      finally
  258.      (if all
  259.          (return-from split-string
  260.                   (cons
  261.                    (make-array (setq l (length all))
  262.                        :fill-pointer l
  263.                                            :adjustable t
  264.                        :initial-contents (nreverse all)
  265.                        :element-type
  266.                                          ' #. (array-element-type "ab")
  267.                                     )
  268.                    (split-string string bag start))))))
  269.  
  270. (eval-when (compile) (proclaim '(special *mread-prompt*)))
  271.  
  272. (defun dbm-read (&optional (stream *standard-input*) (eof-error-p t)
  273.                (eof-value nil) repeat-if-newline  &aux tem  ch
  274.                (mprompt *mread-prompt*) (*mread-prompt* "")
  275.                next
  276.                 )
  277.  
  278.   (when (> (length mprompt) 0)
  279.     (fresh-line *standard-output*)
  280.     (princ mprompt *standard-output*)
  281.         (force-output *standard-output*)
  282.     ;(format t "~&~a" mprompt)
  283.     )
  284.   (tagbody
  285.    top
  286.    (setq ch (read-char stream eof-error-p eof-value))
  287.    (cond ((or (eql ch #\newline) (eql ch #\return))
  288.       (if (and repeat-if-newline *last-dbm-command*)
  289.           (return-from dbm-read *last-dbm-command*)) 
  290.       (go top)
  291.       )
  292.      ((eq ch eof-value) (return-from dbm-read eof-value)))
  293.    ;; ANSI CL portability bug here.  It's undefined if you do a stream
  294.    ;; operation and then unread-char.
  295.    (and (eql ch #\?) (setq next (peek-char nil  stream  nil)))
  296.    (unread-char ch stream)
  297.   )
  298.   (cond ((eql #\: ch)
  299.      (let* ((line (read-line stream eof-error-p eof-value))
  300.         fun)
  301.        (multiple-value-bind
  302.         (keyword n)
  303.         (read-from-string line)
  304.         (setq fun (complete-prop keyword 'keyword 'break-command))
  305.         (and (consp fun) (setq fun (car fun)))
  306.         ;(print (list 'line line))
  307.         (setq *last-dbm-command*
  308.           (cond ((null fun) '(:_none))
  309.             ((get fun 'maxima-read)
  310.              (cons keyword (mapcar 'macsyma-read-string
  311.                            (split-string line " " n ))))
  312.             (t (setq tem
  313.                 ($sconcat "(" (string-right-trim  ";" line) ")"))
  314.                ;(print (list 'tem tem))
  315.                (read  (make-string-input-stream tem)
  316.                   eof-error-p eof-value)))))))
  317.     ((and (eql #\? ch) (member next '(#\space #\tab)))
  318.      (let* ((line (string-trim '(#\space #\tab #\; #\$)
  319.                    (subseq (read-line stream eof-error-p eof-value) 1))))
  320.        `((displayinput) nil (($describe) ,line))))
  321.     (t
  322.      (setq *last-dbm-command* nil)
  323.      #-cmu
  324.      (mread stream eof-value)
  325.  
  326.        ;; At this point, we have peeked at the next character, but
  327.        ;; CMUCL has also deleted that character.  This is a hack.
  328.        ;;
  329.        ;; Read the char that we unread back to the stream.
  330.        ;; Make a new stream consisting of the next char and the
  331.        ;; rest of the actual input.
  332.      #+cmu
  333.      (if (eql #\? ch)
  334.          (let* ((first-char (read-char stream))
  335.             (new-stream (make-concatenated-stream
  336.                  (make-string-input-stream
  337.                   (concatenate 'string (string first-char)
  338.                            (string next)))
  339.                  stream)))
  340.            (mread new-stream eof-value))
  341.          (mread stream eof-value)))))
  342.  
  343.  
  344. (defun grab-line-number (li stream)
  345.   (declare (type (vector ( #. (array-element-type "ab"))) li))
  346.   (cond ((and (> (length li) 3)
  347.           (digit-char-p (aref li 1)))
  348.      (let ((in (get-instream stream)))
  349.        (and in
  350.         (progn
  351.          (multiple-value-bind
  352.           (line pos)
  353.           (read-from-string li nil nil)
  354.           (let ((file (read-from-string li nil nil
  355.                         :start pos)))
  356.             (cond ((and (stringp file) (fixnump line))
  357.                (setf (instream-stream-name in)
  358.                  file)
  359.                (setf (instream-line in)
  360.                  line)))
  361.             )))))))
  362.  
  363.   )
  364.  
  365.  
  366.            
  367.  
  368.  
  369. (defvar *break-level* nil)
  370. (defvar *break-env* nil)
  371. (defvar *top-eof* (cons nil nil))
  372. (defvar *quit-tag* 'macsyma-quit)
  373. ;; should maybe be??
  374. ;;(defvar *quit-tag* 'si::*quit-tag*)
  375.  
  376. (defvar *quit-tags* nil)
  377.  
  378. (defun set-env (bkpt)
  379.   (format *debug-io* "(~a ~a~@[ in ~a~])" (short-name (bkpt-file bkpt))
  380.       (bkpt-file-line bkpt)
  381.       nil                ; (bkpt-function bkpt)
  382.       )
  383.   (format *debug-io* "~&~a:~a::~%" (bkpt-file bkpt)
  384.       (bkpt-file-line bkpt)))
  385. (defvar *diff-mspeclist* nil)
  386. (defvar *diff-bindlist* nil)
  387.  
  388. (defun break-dbm-loop (at)
  389.   (let* (
  390.      (*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*))
  391.      (*break-level* (if (not at) *break-level* (cons t *break-level*)))
  392.      (*quit-tag* (cons nil nil))
  393.      (*break-env* *break-env*)
  394.      (*mread-prompt* "")
  395.      (*diff-bindlist* nil)
  396.      (*diff-mspeclist* nil)
  397.      val
  398.      )
  399.     (declare (special *mread-prompt* ))
  400.     (and (consp at) (set-env at))
  401.     (cond ((null at)
  402.        ($frame 0 nil)))
  403.     (catch 'step-continue
  404.       (catch *quit-tag*
  405.     (unwind-protect
  406.         (do () (())
  407.         (format *debug-io*
  408.             "~&~@[(~a:~a) ~]"  (unless (stringp at) "dbm")
  409.             (length *quit-tags*))
  410.         (setq val
  411.               (catch 'macsyma-quit
  412.             (let ((res (dbm-read *debug-io*  nil *top-eof* t)))
  413.               (declare (special *mread-prompt*))
  414.               (cond ((and (consp res) (keywordp (car res)))
  415.                  (let ((value (break-call (car res)
  416.                               (cdr res) 'break-command)))
  417.                    (cond ((eq value :resume) (return)))
  418.                    ))
  419.                 (t
  420.                  (setq $__ (nth 2 res))
  421.                  (setq $% (meval* $__))
  422.                  (SETQ $_ $__)
  423.                  (displa $%)
  424.                  ))
  425.               nil
  426.               )))
  427.         (and (eql val 'top)
  428.              (throw-macsyma-top))
  429.               )
  430.      (restore-bindings)
  431.     )))))
  432.  
  433. (defun break-quit (&optional (level 0)
  434.                    &aux (current-level (length *break-level*)))
  435.  
  436.   (when (and (>= level 0) (< level current-level))
  437.     (let ((x (nth (- current-level level 1) *quit-tags*)))
  438.       (if (eq (cdr x) 'macsyma-quit)
  439.       (throw 'macsyma-quit 'top)
  440.     (throw (cdr x) (cdr x)))
  441.       ))
  442.   (throw 'macsyma-quit 'top)
  443. )
  444.  
  445.  
  446. (defun break-current ()
  447.   (if *break-level*
  448.       (format *debug-io* "Back to level ~:@(~S~)." (length *break-level*))
  449.       (format *debug-io* "~&Top level."))
  450.   (values))
  451.  
  452. (defun def-break (keyword fun doc)
  453.   (setf (get keyword 'break-command) fun)
  454.   (and doc (setf (get keyword 'break-doc) doc))
  455.   )
  456.  
  457. (defun break-help (&optional key)
  458.   (cond (key
  459.      (if (keywordp key)
  460.          (dolist (v (complete-prop key 'keyword 'break-doc t))
  461.              (format t "~&~%~(~s~)   ~a" v (get v 'break-doc)))))
  462.     (t
  463.      (sloop for v in-package 'keyword
  464.         with doc
  465.         when
  466.         (get v 'break-command)
  467.         collect (cons v (or (get v 'break-doc) "Undocumented"))
  468.         into all
  469.         finally (setq all (sort all 'alphalessp))
  470.         (format t "Break commands start with ':' Any unique substring may be used, eg :r :re :res all work for :resume.~%Command     Description~%
  471. --------     --------------------------------------")   
  472.         (sloop for v in all
  473.                do (format t "~% ~(~s~)     ~a" (car v) (cdr v)))
  474.             ))))
  475. (def-break :help 'break-help "Print help on a break command or with no arguments on all break commands")
  476. (def-break :_none #'(lambda()) nil)
  477. (def-break :next  'step-next
  478.   "Like :step, except that subroutine calls are stepped over")
  479. (def-break :step  'step-into "Step program until it reaches a new source line" )
  480. ;(def-break :location  'loc "" )
  481. (def-break :quit 'break-quit "Quit this level")
  482. (def-break :top  #'(lambda( &rest l)l (throw 'macsyma-quit 'top)) "Throw to top level")
  483.  
  484.  
  485.  
  486. (eval-when (eval load  compile)
  487.  
  488. ;; gcl imports from 'si package
  489. #-gcl  
  490. (defstruct instream stream (line 0 :type fixnum) stream-name)
  491.  
  492. (defstruct (bkpt (:type list)) form file file-line function)
  493.   )
  494.  
  495.  
  496. (defun *break-points* (form  ) 
  497.   (let ((pos(position form *break-points* :key 'car )))
  498.     (format t "Bkpt ~a:" pos)
  499.     (break-dbm-loop  (aref *break-points* pos) )))
  500.  
  501. (eval-when (compile load eval)
  502.    (defstruct (line-info (:type list)) line file)
  503.  )
  504.  
  505. ;;fun = function name eg '$|odeSeriesSolve| and li = offset from beginning of function.
  506. ;;   or= string (filename) and li = absolute position.
  507. ;; 
  508.  
  509. (defun break-function (fun &optional (li 0)  absolute  &aux i tem info form
  510.                fun-line
  511.                )
  512.   (unless debug
  513.       (format t "~&Turning on debugging debugmode(true)")
  514.       (setq debug t))
  515.   (cond ((or (stringp fun)
  516.          (and (mstringp fun) (setq fun ($sconcat fun))))
  517.      (let ((file fun)  start)
  518.        (sloop named joe for v in-package 'maxima with tem  and linfo
  519.           when (and (typep (setq tem (set-full-lineinfo v)) 'vector)
  520.                 (setq linfo (get-lineinfo (aref tem 1)))
  521.                 (equal file (cadr linfo))
  522.                 (fb >= li (setq start (aref tem 0)))
  523.                 (fb <= li (f + start (length (the vector tem)))))
  524.           do (setq fun v li (f - li start -1 ))
  525.          ; (print (list 'found fun fun li  (aref tem 0)))
  526.           (return-from joe nil)
  527.           finally
  528.           (format t "No line info for ~a " fun)
  529.           (return-from break-function nil)
  530.           )
  531.        
  532.        )))
  533.   (setq fun ($concat fun))
  534.   ;(print (list 'fun fun 'hi))
  535.   (cond ((and (setq tem (second (mgetl  fun '(mexpr mmacro))))
  536.           (setq info (get-lineinfo (setq form (third tem))))
  537.           (eq (third info) 'src))
  538.      (setq fun-line (fifth info))
  539.      (or (fixnump fun-line) (setq fun-line (line-info-line info)))
  540.      ;(print (list 'fun-line fun-line))
  541.      (setq form (first-form-line
  542.                 form
  543.                 (setq i (+
  544.                      (if absolute 0 fun-line) li))))
  545.      (unless form
  546.          (if (eql li 0)
  547.              (return-from break-function (break-function fun 1)))
  548.            (format t "~& No instructions recorded for this line ~a of ~a" li
  549.            ($sconcat fun))
  550.        (return-from break-function nil))
  551.      (let ((n (insert-break-point    (make-bkpt :form form
  552.                             :file-line i
  553.                             :file (line-info-file info)
  554.                             :function fun))))
  555.         (format t "~&Bkpt ~a for ~a (in ~a line ~a) ~%"
  556.             n ($sconcat fun) (line-info-file info) i)
  557.         n
  558.           ))
  559.     (t (format t "No line info for ~a " fun))))
  560.  
  561.  
  562.   ;; note  need to make the redefine function, fixup the break point
  563.   ;; list.. 
  564.  
  565. (defun first-form-line (form line &aux tem)
  566.   (cond ((atom form) nil)
  567.     ((and (setq tem (get-lineinfo form)) (eql (car tem) line))
  568.      form)
  569.     (t (sloop for v in (cdr form)
  570.           when (setq tem (first-form-line v line))
  571.           do (return-from first-form-line tem)))))
  572.  
  573. (defun make-break-point (fun ar i)
  574.   (declare (fixnum i) (type (vector t) ar))
  575.   (let* ((tem (aref ar i))
  576.      (linfo (get-lineinfo tem)))
  577.     ;(defstruct (bkpt (:type list)) form file file-line function)    
  578.     (and linfo (list tem (cadr linfo) (car linfo) fun))))
  579.  
  580. (defun dbm-up (n &aux (cur *current-frame*) (m (length *mlambda-call-stack*)))
  581.   (declare (fixnum n m cur))
  582.   (setq m (quotient m 5))
  583.   (setq n (f + n cur))
  584.   (cond ((fb > n m)
  585.      (setq n m))
  586.     ((fb < n 0)
  587.      (setq n 0)))
  588.   ($frame  n nil)
  589.   )
  590.   
  591.  
  592.     
  593. (defun insert-break-point (bpt &aux at)
  594.   (or *break-points* (init-break-points))
  595.   (setq at (or (position nil *break-points*)
  596.            (prog1 (length *break-points*)
  597.          (vector-push-extend  nil *break-points*)
  598.          )))
  599.   (let ((fun (bkpt-function bpt)))
  600.     (push at (get fun 'break-points)))
  601.   (setf (aref *break-points* at) bpt)
  602.   at)
  603.  
  604. (defun short-name (name)
  605.   (let ((Pos (position #\/ name :from-end t)))
  606.     (if pos (subseq name (f + 1 pos)) name)))
  607.  
  608. (defun show-break-point (n &aux disabled)
  609.   (let ((bpt (aref *break-points* n)))
  610.     (when bpt
  611.       (when (eq (car bpt) nil)
  612.     (setq disabled t)
  613.     (setq bpt (cdr bpt)))
  614.       (format t "Bkpt ~a:(~a line ~a)~@[(disabled)~]"
  615.           n (short-name (second bpt))
  616.           (third bpt) disabled)
  617.       (let ((fun (fourth bpt)))
  618.     (format t "(line ~a of ~a)"  (relative-line fun (nth 2 bpt))
  619.         fun
  620.         )))))
  621.  
  622. (defun relative-line (fun l)
  623.   (let ((info (set-full-lineinfo fun)))
  624.     (if info (f - l (aref info 0))
  625.       0)))
  626.  
  627. (defun iterate-over-bkpts (l action)
  628.   (dotimes (i (length *break-points*))
  629.        (if (or (member i l)
  630.            (null l))
  631.            (let ((tem (aref *break-points* i)))
  632.          (setf (aref *break-points* i)
  633.                (case action
  634.              (:delete
  635.               (unless (car tem)
  636.                 (pop tem))    ; disabled or already deleted bkpt
  637.               (if tem (setf (get (bkpt-function tem) 'break-points)
  638.                     (delete i (get (bkpt-function tem) 'break-points))))
  639.               nil)
  640.              (:enable
  641.               (if (eq (car tem) nil) (cdr tem) tem))
  642.              (:disable
  643.               (if (and tem (not (eq (car tem) nil)))
  644.                   (cons nil tem)
  645.                 tem))
  646.              (:show
  647.               (when tem (show-break-point i)
  648.                 (terpri))
  649.               tem
  650.               )))))))
  651.  
  652. ;; get the most recent function on the stack with step info.
  653.  
  654. (defun current-step-fun ( &aux fun)
  655.   (sloop for i below 100000
  656.      while (setq fun (frame-info i))
  657.      do (cond ((and (symbolp fun) (set-full-lineinfo fun))
  658.            (return-from current-step-fun fun))))
  659.   )
  660.  
  661.  
  662.  
  663. (def-break :bt '$backtrace "Print a backtrace of the stack frames")
  664.  
  665.  
  666. (def-break :info #'(lambda (&optional type)
  667.      (case type
  668.        (:bkpt  (iterate-over-bkpts nil :show)(values))
  669.        (otherwise
  670.         (format t "usage: :info :bkpt -- show breakpoints")
  671.         ))) "Print information about item")
  672.  
  673.  
  674.  
  675. (defmacro lisp-quiet (&rest l)
  676.    (setq *mread-prompt* "")
  677.    (eval (cons 'progn l)))
  678.  
  679. (def-break :lisp-quiet 'lisp-quiet "Evaluate the lisp form without printing a prompt")
  680.  
  681. (def-break :lisp 'lisp-eval "Evaluate the lisp form following on the line")
  682. (defmacro lisp-eval (&rest l)
  683.   (dolist  (v (multiple-value-list (eval (cons 'progn l))))
  684.        (fresh-line *standard-output*)
  685.        (princ v))
  686.   )
  687.    
  688. (def-break :delete  #'(lambda (&rest l) (iterate-over-bkpts l :delete)(values))
  689.   "Delete all breakpoints, or if arguments are supplied delete the specified
  690. breakpoints" )
  691. (def-break :frame  '$frame "With an argument print the selected stack frame.
  692. Otherwise the current frame." )
  693. (def-break :resume  #'(lambda () :resume) "Continue the computation." )
  694. (def-break :continue  #'(lambda () :resume)  "Continue the computation." )
  695.  
  696.  
  697.  
  698. (def-break :disable 
  699.       #'(lambda (&rest l) (iterate-over-bkpts l :disable)(values))
  700.       "Disable the specified breakpoints, or all if none are specified")
  701. (def-break :enable  #'(lambda (&rest l) (iterate-over-bkpts l :enable)(values))
  702.   "Enable the specified breakpoints, or all if none are specified" )
  703.  
  704.  
  705. (def-break :break  'do-break
  706.   "Set a breakpoint in the specified FUNCTION at the
  707. specified LINE offset from the beginning of the function.
  708. If FUNCTION is given as a string, then it is presumed to be
  709. a FILE and LINE is the offset from the beginning of the file." )
  710.  
  711. ;; force the rest of the line to be broken at spaces,
  712. ;; and each item read as a maxima atom.
  713. (setf (get :break 'maxima-read) t)
  714.  
  715.  
  716. (defmacro do-break (&optional name &rest l)
  717.   (declare (special *last-dbl-break*))
  718.   (cond ((null name)
  719.      (if *last-dbl-break*
  720.         (let ((fun  (nth 3 *last-dbl-break*)))
  721.           (break-function fun (nth 2 *last-dbl-break*) t)))
  722.      )
  723.     (t (eval `(break-function ',name ,@l)))))
  724.  
  725.  
  726.  
  727. ;; this just sets up a counter for each stream.. we want
  728. ;; it to start at one.
  729.  
  730. ;;========
  731. (defun get-lineinfo (form )
  732.   (cond ((consp form)
  733.       (if (consp (cadar form))
  734.           (cadar form)
  735.         (if (consp (caddar form))
  736.         (caddar form)
  737.         nil)))
  738.     (t nil)))
  739.  
  740. ;; restore-bindings from an original binding list.
  741. (defun restore-bindings ()
  742.   (mbind *diff-bindlist* *diff-mspeclist* nil)
  743.   (setf *diff-bindlist* nil *diff-mspeclist* nil)
  744.   )
  745.  
  746. (defun remove-bindings (the-bindlist)
  747.   (sloop for v on bindlist with var
  748.      while v
  749.      until (eq v the-bindlist)
  750.      do
  751.      (setq var (car v))
  752.      (push var *diff-bindlist*)
  753.      (push (symbol-value var) *diff-mspeclist*)
  754.      (COND ((EQ (CAR MSPECLIST) MUNBOUND)
  755.         (MAKUNBOUND VAR) (DELQ VAR $VALUES 1))
  756.            (T (LET ((MUNBINDP T)) (MSET VAR (CAR MSPECLIST)))))
  757.      (SETQ MSPECLIST (CDR MSPECLIST) BINDLIST (CDR BINDLIST))
  758.  
  759.      ))
  760.  
  761. (defun $frame (&optional (n 0) (print-frame-number t))
  762.   (restore-bindings)
  763.   (multiple-value-bind
  764.    (fname vals params backtr lineinfo bdlist)
  765.    (print-one-frame n print-frame-number)
  766.    backtr params vals fname
  767.    (remove-bindings bdlist)
  768.    (when lineinfo
  769.      (fresh-line *debug-io*)
  770.      (format *debug-io* "~a:~a::~%" (cadr lineinfo)
  771.          (+ 0 (car lineinfo))))
  772.    (values)
  773.    ))
  774.